perm filename FRECRD.F4[KI,ALS] blob
sn#094485 filedate 1974-04-02 generic text, type T, neo UTF8
00100 SUBROUTINE FRECRD(A)
00200 IMPLICIT INTEGER(A-Z)
00300 DIMENSION A(2)
00400 DATA SPEED/25600/
00500 DATA NUM/9216/
00600 CALL FIXUPA(A)
00700 TOTWRD=3*NUM
00800 PT1=1
00900 PT2=1+NUM
01000 PT3=1+NUM+NUM
01100 CALL TORITE(JFN,'LISTEN.TMP')
01200 CALL SETWRT(1,JFN)
01300 CALL STRNGO('ABOUT TO TRY TO ASSIGN ADC ')
01400 CALL SETAD(11,SPEED)
01500 CALL STRNGO(' - SUCCESSFUL')
01600 CALL LFCR
01700 NSEC=5
01800 NSAMP=25600*NSEC
01900 NWORDS=NSAMP/3
02000 TEST=NSAMP-NWORDS*3
02100 IF(TEST.GT.0)NWORDS=NWORDS+1
02200 NPAGES=NWORDS/512
02300 TEST=NWORDS-512*NPAGES
02400 IF(TEST.GT.0)NPAGES=NPAGES+1
02500 NWORDS=512*NPAGES
02600 NITER=NWORDS/(3*NUM)
02700 NLEFT=NWORDS-3*NUM*NITER
02800 FL1=0
02900 FL2=0
03000 FL3=0
03100 IF(NLEFT.GT.NUM)GO TO 1
03200 NL1=NLEFT
03300 IF(NL1.LE.0)FL1=1
03400 IF(NL1.LE.0)NL1=1
03500 NL2=1
03600 FL2=1
03700 NL3=1
03800 FL3=1
03900 GO TO 3
04000 1 CONTINUE
04100 NL1=NUM
04200 NLEFT=NLEFT-NUM
04300 IF(NLEFT.GT.NUM)GO TO 2
04400 NL2=NLEFT
04500 IF(NL2.LE.0)FL2=1
04600 IF(NL2.LE.0)NL2=1
04700 NL3=1
04800 FL3=1
04900 GO TO 3
05000 2 CONTINUE
05100 NL2=NUM
05200 NL3=NLEFT-NUM
05300 IF(NL3.LE.0)FL3=1
05400 IF(NL3.LE.0)NL3=1
05500 3 CONTINUE
00100 CALL STRNGO('ABOUT TO TRY TO ASSIGN XGP ')
00200 CALL SETXGP
00300 CALL STRNGO(' - SUCCESSFUL')
00400 CALL LFCR
00500 CALL GCORE(TOTWRD)
00600 CALL LOCK
00700 IF(NITER.GT.0)GO TO 4
00800 CALL ADINP1(NL1,A(PT1))
00900 CALL ADINP2(NL2,A(PT2))
01000 CALL ADINP3(NL3,A(PT3))
01100 GO TO 7
01200 4 CONTINUE
01300 CALL ADINP1(NUM,A(PT1))
01400 CALL ADINP2(NUM,A(PT2))
01500 CALL ADINP3(NUM,A(PT3))
01600 IF(NITER.LE.1)GO TO 6
01700 DO 5 LLL=2,NITER
01800 CALL FSTOUT(NUM,A(PT1))
01900 CALL ADINP1(NUM,A(PT1))
02000 CALL FSTOUT(NUM,A(PT2))
02100 CALL ADINP2(NUM,A(PT2))
02200 CALL FSTOUT(NUM,A(PT3))
02300 CALL ADINP3(NUM,A(PT3))
02400 5 CONTINUE
02500 6 CONTINUE
02600 CALL FSTOUT(NUM,A(PT1))
02700 CALL ADINP1(NL1,A(PT1))
02800 CALL FSTOUT(NUM,A(PT2))
02900 CALL ADINP2(NL2,A(PT2))
03000 CALL FSTOUT(NUM,A(PT3))
03100 CALL ADINP3(NL3,A(PT3))
03200 7 CONTINUE
03300 IF(FL1.LE.0)CALL FSTOUT(NL1,A(PT1))
03400 CALL ADINP1(1,A(PT1))
03500 IF(FL2.LE.0)CALL FSTOUT(NL2,A(PT2))
03600 CALL ADINP2(1,A(PT2))
03700 IF(FL3.LE.0)CALL FSTOUT(NL3,A(PT3))
03800 CALL UNLOCK
03900 CALL RELXGP
04000 CALL STRNGO('XGP RELEASED')
04100 CALL LFCR
04200 CALL RELAD
04300 CALL STRNGO('ADC RELEASED')
04400 CALL LFCR
04500 CALL SCLOSE(JFN)
04600 RETURN
04700 END